home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / queens.stk < prev    next >
Encoding:
Text File  |  1996-07-05  |  8.8 KB  |  319 lines
  1. #!/usr/local/bin/stk -f
  2.  
  3. ; -* Lisp -*-
  4.  
  5. ; Yet another "my first STk program" type thing.  This one is the "8
  6. ; queens" puzzle.  You try to figure out how to place 8 queens on a
  7. ; chessboard so that none of the queens can be taken in a single move.
  8. ;
  9. ; You can do it yourself (and it will make sure you follow the rules)
  10. ; or you can ask it to solve the puzzle starting with a given board
  11. ; configuration.
  12. ;
  13. ; It expects to fined the queen bitmap in the images directory 
  14. ; in the STk library directory.
  15.  
  16. ; 27 Jan 96: ported to STk 3.0
  17.  
  18. ; Grant Edwards
  19. ;
  20. ; grante@winternet.com
  21. ; grante@rosemount.com
  22. ; grante@ep.frco.com
  23. ; edwards@grad.cs.umn.edu
  24.  
  25.  
  26.  
  27. (define queen-bitmap (string-append "@" *STk-library* "/images/queen"))
  28.  
  29. ; size of board (it's square)
  30.  
  31. (define size 8)
  32.  
  33.  
  34. ; Predicate that is true if the queens at p1 and p2 can't take each
  35. ; other in 1 move.  p1 and p2 are pairs of the form ( x . y ) where
  36. ; x is column and y is row (both from 0 to size-1).
  37.  
  38. (define legal-position-pair? 
  39.   (lambda (p1 p2)
  40.     (let ([x1 (car p1)] [y1 (cdr p1)] [x2 (car p2)] [y2 (cdr p2)])
  41.       (not (or 
  42.          (= x1 x2) 
  43.          (= y1 y2) 
  44.          (= (abs (- x1 x2)) (abs (- y1 y2))))))))
  45.  
  46.  
  47. ; Predicate that is true if none of the queens in list history can
  48. ; take queen at postion new in one move.  "history" is a list of
  49. ; position pairs.  "new" is the position pair which we are testing.
  50.  
  51. (define legal-move? 
  52.   (lambda (history new)
  53.     (cond 
  54.       [(null? history) #t]
  55.       [(not (legal-position-pair? (car history) new)) #f]
  56.       [else (legal-move? (cdr history) new)])))
  57.  
  58.  
  59. ; This is the procedure that solves the puzzle given a list of
  60. ; occupied squares and a list of empty rows.  It's also passed a
  61. ; continuation so that it can abort when the user asks it to stop.
  62.  
  63. ; Add a legal move to history list and recurse to build up strings of
  64. ; legal moves.  The chessboard is updated as pieces are placed. When
  65. ; it reaches the required length, it waits for user to press the Next
  66. ; or Stop button. "history" is a list of pairs that denotes where
  67. ; there are already queens.  "ylist" is a list of rows that still need
  68. ; to be filled. "break" is a continuation to be called when the
  69. ; procedure is to be aborted.
  70.  
  71. (define add-queen 
  72.   (lambda (history ylist break)
  73.     (cond
  74.       [stopPushed    (break #f)]
  75.       [(null? ylist) (begin (write history)(newline)(waitForNextButton)(if stopPushed (break #f)))]
  76.       [else          (let ([newy (car ylist)])
  77.                (dotimes (newx size)
  78.              (if (legal-move? history (cons newx newy))
  79.                (begin
  80.                  (activate-button newx newy)
  81.                  (update)
  82.                  (add-queen (cons (cons newx newy) history) (cdr ylist) break)
  83.                  (deactivate-button newx newy)
  84.                  (update)))))])))
  85.  
  86. ; global boolean used to keep track of whether or not the user is
  87. ; allowed to rearrange the board.
  88.  
  89. (define userModsEnabled #t)
  90.  
  91.  
  92. ; set up button states and solve the puzzle starting with the current
  93. ; board configuration.
  94.  
  95. (define do-solve 
  96.   (lambda ()
  97.     (set! stopPushed #f)
  98.     (.upper.solve 'configure :state 'disabled)
  99.     (.upper.stop  'configure :state 'normal)
  100.     (.upper.clear 'configure :state 'disabled)
  101.     (set! userModsEnabled #f)
  102.     (call/cc (lambda (break)(add-queen (current-positions)(empty-rows) break)))
  103.     (.upper.stop 'configure :state 'disabled)
  104.     (.upper.clear 'configure :state 'normal)
  105.     (set! userModsEnabled #t)
  106.     (.upper.solve 'configure :state 'normal)))
  107.  
  108.  
  109. ; define some procedures to create and operate on matrixes
  110.  
  111. (define make-matrix 
  112.   (lambda (i j v) 
  113.     (let ([m (make-vector i)])
  114.       (dotimes (c j m)
  115.     (vector-set! m c (make-vector j v))))))
  116.  
  117. (define matrix-ref 
  118.   (lambda (m i j)
  119.     (vector-ref (vector-ref m i) j)))
  120.  
  121. (define matrix-row 
  122.   (lambda (m i)
  123.     (vector-ref m i)))
  124.  
  125. (define matrix-set! 
  126.   (lambda (m i j v)
  127.     (vector-set! (vector-ref m i) j v)))
  128.  
  129.  
  130. ; Create two matrixes.  Each has an entry for each square on the
  131. ; board.  One matrix is Tk button procedures, the other is booleans
  132. ; that reflect whether or not the square is occupied.
  133.  
  134. (define board-buttons (make-matrix size size #f))
  135. (define board-states  (make-matrix size size #f))
  136.   
  137.  
  138. ; redraw the button so that it is occupied and update the matrix of
  139. ; booleans
  140.  
  141. (define activate-button 
  142.   (lambda (x y)
  143.     ((matrix-ref board-buttons y x) 'configure :relief 'raised :foreground "#000")
  144.     (matrix-set! board-states y x #t)))
  145.  
  146.  
  147. ; redraw the button so that it is empty and update the matrix of
  148. ; booleans
  149.  
  150. (define deactivate-button 
  151.   (lambda (x y)
  152.     (let* ([b (matrix-ref board-buttons y x)]
  153.         [bg (cadr (cdddr (b 'configure :background)))])
  154.       (b 'configure :relief 'flat :foreground bg)
  155.       (matrix-set! board-states y x #f))))
  156.  
  157. ; flash a button
  158.  
  159. (define flash-button 
  160.   (lambda (x y)
  161.     ((matrix-ref board-buttons y x) 'flash)))
  162.  
  163.  
  164. ; Procedure called when the user clicks on a square in the chessboard.
  165. ; If user modifications are not enabled, then do nothing.  Otherwise
  166. ; toggle the sate of the square.  When placing a queen on a previously
  167. ; empty square, remove existing queens that could be taken by the new
  168. ; one.
  169.  
  170. (define toggle-button 
  171.   (lambda (x y)
  172.     (cond
  173.       [ (not userModsEnabled) #f]
  174.       [ (matrix-ref board-states y x)  (deactivate-button x y)]
  175.       [else (begin
  176.           (activate-button x y)
  177.           (update)
  178.           (dotimes (ox size) 
  179.         (dotimes (oy size)
  180.           (if (and
  181.             (matrix-ref board-states  oy ox)
  182.             (not (and (= x ox) (= y oy)))
  183.             (not (legal-position-pair? (cons x y) (cons ox oy))))
  184.               (begin
  185.             (flash-button ox oy)
  186.             (flash-button ox oy)
  187.             (flash-button ox oy)
  188.             (deactivate-button ox oy)
  189.             (update))))))])))
  190.  
  191.  
  192. ; clear the board
  193.  
  194. (define clear-board 
  195.   (lambda ()
  196.     (dotimes (x size) (dotimes (y size) (deactivate-button x y)))))
  197.  
  198.  
  199. ; Procedures to return a list of consecutive integers from start to
  200. ; end (inclusive).
  201.  
  202. (define interval 
  203.   (lambda (start end)
  204.     (let loop ([s start] [e end] [l ()])
  205.       (if (> s e) l (loop s (- e 1) (cons e l))))))
  206.  
  207. (define rinterval 
  208.   (lambda (start end)
  209.     (let loop ([s start] [e end] [l ()])
  210.       (if (> s e) l (loop (+ s 1) e (cons s l))))))
  211.    
  212.  
  213. ; Return a list of integers that identify the rows on the chessboard
  214. ; that are empty
  215.  
  216. (define empty-rows 
  217.   (lambda ()
  218.     (let loop ([rows (rinterval 0 (- size 1))] [empty ()])
  219.       (if (null? rows)
  220.     empty
  221.     (if (member #t (vector->list (matrix-row board-states (car rows))))
  222.       (loop (cdr rows) empty)
  223.       (loop (cdr rows) (cons (car rows) empty)))))))
  224.  
  225.  
  226. ; Return a list of pairs ( x . y ) indicating which squares are
  227. ; currently occupied.
  228.  
  229. (define current-positions 
  230.   (lambda ()
  231.     (let ([p ()])
  232.       (dotimes (x size) 
  233.     (dotimes (y size) 
  234.       (if (matrix-ref board-states y x) (set! p (cons (cons x y) p)))))
  235.       p)))
  236.  
  237.  
  238. ; Booleans used to detect when user presses a button 
  239.  
  240. (define nextOrStopPushed #f)
  241. (define stopPushed #f)
  242.  
  243.  
  244. ; Procedure to wait for the user to press either the next or stop
  245. ; buttons.
  246.  
  247. (define waitForNextButton 
  248.   (lambda () 
  249.     (.upper.next 'configure :state 'normal)
  250.     (tkwait 'variable 'nextOrStopPushed)
  251.     (.upper.next 'configure :state 'disabled)))
  252.  
  253.  
  254. ; Define two frames.  The upper will hold control buttons, the lower
  255. ; the chessboard buttons
  256.  
  257. (frame '.lower :relief 'raised :borderwidth 2)
  258. (frame '.upper)
  259.  
  260. ; procedure that does nothing other than return the break symbol
  261.  
  262. (define noop-break (lambda () 'break))
  263.  
  264.  
  265. ; add a frame to the lower frame for each row of sqaures on the
  266. ; chessboard and fill that row with buttons (one per square).
  267.  
  268. (dotimes (y size)
  269.   (let ([rowframe (format #f ".lower.row~a" y)])
  270.     (frame rowframe)
  271.     (dotimes (x size)
  272.       (let* ([bn (format #f "~a.b~a" rowframe x)]
  273.           [bp (eval (button bn 
  274.               :bitmap queen-bitmap
  275.               :highlightthickness 0
  276.               :relief 'flat))])
  277.         (matrix-set! board-buttons y x bp)
  278.         (let ([bg (if (odd? (+ x y)) "#bbb" "#eee")])
  279.           (bp 'configure :background bg :activebackground "#fff" :foreground bg))
  280.         (bind bn "<Button-1>" (lambda () (toggle-button x y) 'break))
  281.         (bind bn "<Any-Enter>" noop-break)
  282.         (bind bn "<Any-Leave>" noop-break)
  283.         (bind bn "<ButtonRelease-1>"  noop-break)
  284.         (pack bn :side 'left)
  285.         )
  286.       )
  287.     (pack rowframe :side 'bottom)
  288.     )
  289.   )
  290.  
  291.  
  292. ; add control buttons to upper frame
  293.  
  294. (button '.upper.quit  :text "Quit" :command (lambda () (exit)))
  295. (button '.upper.solve :text "Solve" :command do-solve)
  296. (button '.upper.Clear :text "Clear" :command clear-board)
  297. (button '.upper.next 
  298.     :text "Next" 
  299.     :state 'disabled 
  300.     :command (lambda () (set! stopPushed #f)(set! nextOrStopPushed #t)))
  301. (button '.upper.stop 
  302.     :text "Stop" 
  303.     :state 'disabled 
  304.     :command (lambda () (set! stopPushed #t)(set! nextOrStopPushed #t)))
  305. (frame  '.upper.fill)
  306. (pack '.upper.solve :side 'left)
  307. (pack '.upper.next :side 'left)
  308. (pack '.upper.stop :side 'left)
  309. (pack '.upper.clear :side 'left)
  310. (pack '.upper.quit :side 'right)
  311. (pack '.upper.fill :side 'right)
  312.  
  313. ; arrange the two top level frames
  314.  
  315. (pack '.upper :side 'top :fill 'x)
  316. (pack '.lower :side 'bottom) 
  317.  
  318.  
  319.